home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / oou-utils.lisp < prev   
Encoding:
Text File  |  1992-09-02  |  10.6 KB  |  290 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;; oou-utils.lisp
  3. ;;
  4. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  5. ;; All Rights Reserved
  6. ;;
  7. ;; author: Mark A. Tapia markt@dgp.utoronto.ca or markt@dgp.toronto.edu
  8. ;;
  9. ;;  Part of this code is from the oodles-of-utils package
  10. ;;  with modifications for the traps to work under MCL2.0f2
  11. ;;  and with support for color quickkdraw added.
  12. ;; Change history
  13. ;;  1992-05-13 added support for color window manager and macros for
  14. ;;             saving a rectangular portion of the screen bit/pixmap,
  15. ;;                executing any number of forms and then restoring the rectangular
  16. ;;             bit/pixmap.
  17. ;; 
  18. ;;  1992-05-22 compatability features added for MCL2.0f...
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20.  
  21. (in-package menus)
  22. (export '(push-after with-wmgr-view queued-modal-dialog containing-view))
  23. (provide :oou-utils)
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;; GDevice-u.Lisp
  27. ;;
  28. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  29. ;; All Rights Reserved
  30. ;;
  31. ;; author: Michael S. Engber
  32. ;;
  33. ;; utilities for working with g-devices
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35. (defun get-max-device (&optional globalRect)
  36.   (if globalRect
  37.     (#_GetMaxDevice :ptr globalRect)
  38.     (with-dereferenced-handles ((GrayRgn_p (%get-ptr (%int-to-ptr #$GrayRgn))))
  39.       (#_GetMaxDevice :ptr (pref GrayRgn_p :Region.rgnBBox)))))
  40.  
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42. ;; QuickDraw-u.lisp
  43. ;;
  44. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  45. ;; All Rights Reserved
  46. ;;
  47. ;; author: Michael S. Engber
  48. ;;
  49. ;; utilities for quickdraw
  50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51.  
  52. (defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  53.   (let ((state (gensym)))
  54.     `(rlet ((,state :PenState))
  55.        (require-trap #_GetPenState :ptr ,state)
  56.        (unwind-protect
  57.          (progn
  58.            ,@(when pnLoc    `((require-trap #_MoveTo :long ,pnLoc)))
  59.            ,@(when pnSize   `((require-trap #_PenSize :long ,pnSize)))
  60.            ,@(when pnMode   `((require-trap #_PenMode :signed-integer ,pnMode)))
  61.            ,@(when pnPat    `((require-trap #_PenPat :ptr ,pnPat)))
  62.            ,@(when pnPixPat `((require-trap #_PenPixPat :ptr ,pnPixPat)))
  63.            ,@body)
  64.          (require-trap #_SetPenState :ptr ,state)))))
  65.   
  66.   ;;;;;;;;;;
  67.   ;;font macros
  68.   
  69.   (defmacro with-font-spec (font-spec &body body)
  70.     (if (and (listp font-spec) (every #'constantp font-spec))
  71.       (multiple-value-bind (ff ms) (font-codes font-spec)
  72.         `(with-font-codes ,ff ,ms ,@body))
  73.       (let ((ff (gensym))
  74.             (ms (gensym)))
  75.         `(multiple-value-bind (,ff ,ms) (font-codes ,font-spec)
  76.            (with-font-codes ,ff ,ms ,@body)))))
  77.   
  78.   ;;;;;;;;;;
  79.   ;;clip macros
  80.   
  81.   (defmacro with-clip-rgn (clip-rgn &body body)
  82.     (let ((old-clip (gensym)))
  83.       `(with-macptrs ((,old-clip (require-trap #_NewRgn)))
  84.          (unwind-protect
  85.            (progn
  86.              (require-trap #_GetClip :ptr ,old-clip)
  87.              (require-trap #_SetClip :ptr ,clip-rgn)
  88.              ,@body)
  89.            (require-trap #_SetClip :ptr ,old-clip)
  90.            (require-trap #_DisposeRgn :ptr ,old-clip)))))
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ;; end of quickdraw-u routines from oodles-of-utils
  94.  
  95. ;;various patches that are standard in MCL2.0f...
  96. ;; From patches.lisp in the oodles-of-utils package
  97. #+mcl-final
  98. (defmacro pref (pointer accessor)
  99.   `(rref ,pointer ,accessor :storage :pointer))
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101.  
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ;; simple-view-ce.Lisp
  105. ;;
  106. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  107. ;; All Rights Reserved
  108. ;;
  109. ;; author: Michael S. Engber
  110. ;;
  111. ;; methods for the view class
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113.  
  114. ;; window manager
  115.  
  116. (defclass WMgr-view (simple-view) ())
  117.  
  118. (defmethod view-origin ((sv  WMgr-view)) (declare (ignore sv)) #@(0 0))
  119.  
  120. (defmethod view-clip-region ((sv WMgr-view))
  121.   (declare (ignore sv))
  122.   (#_SetRectRgn :ptr ccl::*simple-view-clip-region* 
  123.    :signed-integer -32768 :signed-integer -32768 
  124.    :signed-integer 32767 :signed-integer 32767)
  125.   ccl::*simple-view-clip-region*)
  126.  
  127. ;; Routine added to get the appropriate window manager port Markt
  128. (defun get-wmgrport ()
  129.   (%get-ptr (%int-to-ptr (if *color-available* 
  130.                            #$WMgrCPort   ; colorQd window-manager
  131.                            #$WMgrPort    ; old Qd window manager
  132.                            ))))
  133.  
  134. (defmethod wptr ((sv WMgr-view))
  135.   (if (pointerp (slot-value sv 'wptr))
  136.     (slot-value sv 'wptr)
  137.     (setf (slot-value sv 'wptr) (get-wmgrPort))))
  138.  
  139. (defvar *WMgr-view*)
  140.  
  141. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  142. ;; end of routines from simple-view-ce.Lisp
  143.  
  144. (defun init-wmgr ()
  145.   (setq *WMGR-view* (make-instance 'WMgr-view))
  146.   (wptr *wmgr-view*)                    ; access the window pointer field
  147.   *wmgr-view*)
  148.  
  149. (defun remove-wmgr ()
  150.   (makunbound '*WMGR-view*))
  151.  
  152. (defun get-wmgr ()
  153.   (unless (and (boundp '*WMGR-view*)
  154.                *wmgr-view*)
  155.     (init-wmgr))
  156.   *WMGR-view*)
  157.  
  158. (defmacro with-wmgr-view (&body body)
  159.   `(progn (get-wmgr)
  160.           (with-focused-view *WMGR-view*
  161.             ,@body
  162.             )))
  163.  
  164. (defmacro push-after (el list)
  165.   ;; add the element to the end of the list 
  166.   `(setf ,list (nconc ,list (list ,el))))
  167.  
  168. (defun check-wmgr ()
  169.   ;; remove and then add #'init-wmgr to end of *lisp-startup-functions*
  170.   (setq *lisp-startup-functions*
  171.         (remove 'init-wmgr *lisp-startup-functions* :key #'function-name))
  172.   (push-after #'init-wmgr *lisp-startup-functions*)
  173.   
  174.   ; remove and then add #'remove-wmgr to the front of the *save-exit-functions*
  175.   (setq *save-exit-functions* 
  176.         (remove 'remove-wmgr *save-exit-functions* :key #'function-name))
  177.   (push  #'remove-wmgr *save-exit-functions*))
  178.  
  179. (defun get-gport (view)
  180.   ;; retrieves the underlying port-pixmap, and the two corners of
  181.   ;; the port-rect for a view which possibly straddles screens
  182.   (let ((port (wptr view)))
  183.     (when port
  184.       (let* ((port-rect (rref port :grafport.portrect))
  185.              (screen-gdevice (get-max-device port-rect))
  186.              (screen-top (rref screen-gdevice :gdevice.gdrect.topLeft))
  187.              (screen-bottom (rref screen-gdevice :gdevice.gdrect.bottomRight))
  188.              (port-pmap (rref screen-gdevice :gdevice.gdpmap)))
  189.         (values port-pmap               ; the screen pixmap
  190.                 screen-top              ; the top left corner of the screen port rect
  191.                 screen-bottom           ; the bottom right corner
  192.                 )))))
  193.  
  194. ;; macros for saving/restoring screen pixmap images
  195. (defmacro safe-kill-picture (picture-var)
  196.   `(progn 
  197.      (when (handlep ,picture-var)
  198.        (kill-picture ,picture-var))
  199.      (setq ,picture-var nil)))
  200.  
  201. (defmacro with-saved-screen-map ((view clip-rect1 &key (saved-picture (gensym))
  202.                                        keep) &rest body)
  203.   ;; Executes the body which may change a portion of the screen within the
  204.   ;; the clip-rection clip-rect1 rectangular portion of the screen 
  205.   ;; (expressed in global coordinates)
  206.   ;; Within the body of the form, saved-picture is bound to the picture
  207.   ;; corresponding to the clipped image of the bit map.
  208.   ;; Upon normal or abnormal termination of the form, restores the screen image
  209.   ;; and either deletes the saved-picture (default) or returns the saved-picture.
  210.   ;; The value of the body is not returned.
  211.   `(let (,saved-picture)
  212.      (unwind-protect
  213.        (progn
  214.          (setq ,saved-picture (save-screen-map ,view ,clip-rect1))
  215.          (with-clip-rect ,clip-rect1
  216.            ,@body))
  217.        (restore-screen-map ,saved-picture ,clip-rect1)
  218.        (unless ,keep 
  219.         (safe-kill-picture ,saved-picture)))))
  220.  
  221. (defun save-screen-map (view clip-rect1)
  222.   ;; saves the portion of the screen corresponding to the  global rectangle
  223.   ;; clip-rect1 which overlaps the gdevice associated with the view
  224.   (when (pointerp (wptr view))
  225.     (multiple-value-bind (pixmap topLeft bottomRight)
  226.                          (get-gport view)
  227.       (when pixmap
  228.         (rlet ((r :rect :topLeft topLeft :bottomRight bottomRight))
  229.           (intersect-rect clip-rect1 r r)
  230.           (unless (empty-rect-p r)
  231.             (let ((pict (#_OpenPicture :ptr clip-rect1)))
  232.               (ccl::with-macptrs ((pixMap_h pixmap))
  233.                 (with-dereferenced-handles ((pixMap_p pixMap_h))
  234.                   (#_CopyBits :ptr pixmap_p
  235.                    :ptr pixmap_p
  236.                    :ptr clip-rect1
  237.                    :ptr clip-rect1
  238.                    :word 0        ;transfer mode
  239.                    :ptr (%null-ptr))
  240.                   (#_ClosePicture))
  241.                 pict))))))))
  242.  
  243. (defun restore-screen-map (screen-picture clip-rect1)
  244.   ;; restores the portion of the screen saved in the picture screen-picture
  245.   ;; corresponding to the global rectangle clip-rect1
  246.   (with-wmgr-view
  247.     (when (handlep screen-picture)
  248.       (#_DrawPicture :ptr screen-picture :ptr clip-rect1))))
  249.  
  250.  
  251. (check-wmgr)                            ; fix the startup and exit functions
  252. (init-wmgr)                             ; initialize the *wmgr-view*
  253.  
  254. (defun queued-modal-dialog (window &optional (close-on-return t))
  255.   "Similar to modal-dialog, but supports eval-enqueue actions"
  256.   (unwind-protect
  257.     (catch-cancel 
  258.       (loop
  259.         while (and (WINDOW-SHOWN-P window) (wptr window))
  260.         do (event-dispatch)
  261.         (when *eval-queue*
  262.           (loop
  263.             while *eval-queue*
  264.             do (eval (pop *eval-queue*))))))
  265.     (when (and (wptr window) close-on-return)
  266.       (window-close window))))
  267.  
  268. #|
  269. ;; test the screen saver macro
  270. (defun box-point (dim)
  271.   (make-point dim dim))
  272. (defun max-dim (point)
  273.   (max (point-h point) (point-v point)))
  274. (defun test-screen-saver (topLeft bottomRight)
  275.   (rlet ((r :rect :topLeft topLeft :bottomRight bottomRight))
  276.     
  277.     (let ((win (make-instance 'window :view-size #@(400 400) :view-position :centered)))
  278.       (with-saved-screen-map (win r :saved-picture saved-picture) ; so we can use the saved-picture
  279.         (window-select win)
  280.         (with-wmgr-view 
  281.           (#_fillRect :ptr r :ptr *light-gray-pattern*))
  282.         (with-port (wptr win)
  283.           (#_drawPicture :ptr saved-picture :ptr r)    ; draw the saved pixel map
  284.           (sleep 1)))
  285.       (sleep 1)                         ; show the restored portion of the screen
  286.       (window-close win))))
  287. (test-screen-saver #@(0 0) #@(200 300))
  288.      
  289. |#
  290.